home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 October / macformat-005.iso / Shareware City / Developers / xlispmac / lisp / COMMON2.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-28  |  13.6 KB  |  431 lines  |  [TEXT/xlsp]
  1. ; Fill in "missing" Common Lisp definitions
  2. ; However, those that concern features of Common Lisp not implemented in
  3. ; XLISP (such as the compiler, arrays, bignums...) are not implemented here.
  4. ; Unlike functions in COMMON.LSP, these are not documented in the manual.
  5.  
  6. ; You might want to only include those functions your application needs.
  7.  
  8. ; Tom Almy, 7/93
  9.  
  10. #-:common (load "common")  ; We need these always!
  11.  
  12. (in-package "XLISP")
  13.  
  14. (export '(char-code-limit array-in-bounds-p assert assoc-if assoc-if-not
  15.           ccase char-name character check-type copy-seq copy-symbol
  16.       ctypecase delete-duplicates ecase etypecase fifth sixth
  17.       seventh eighth ninth tenth float-sign hash-table-p isqrt
  18.       keywordp packagep ldiff make-list make-string make-sequence
  19.       member-if member-if-not merge mismatch nbutlast nreconc
  20.       prin1-to-string princ-to-string probe-file rassoc
  21.       rassoc-if rassoc-if-not read-from-string realp
  22.       revappend tailp typecase sleep with-open-stream))
  23.  
  24. (defconstant char-code-limit 127)
  25.  
  26. ;; Apropos function contributed by Jan Kok, kok@cs.ColoState.edu
  27.  
  28. #-:packages
  29. (defun apropos-list (string)
  30.        (let ((str (string string)) ; convert to string, if symbol is passed
  31.          (result nil))
  32.         (dotimes (i (length *obarray*) result)
  33.              (dolist (sym (elt *obarray* i))
  34.                  (if (search str (string sym) :test #'char-equal)
  35.                  (push sym result))))))
  36. #-:packages
  37. (defun apropos (string) 
  38.        (mapcar #'(lambda (x)
  39.              (format t "~&~s" x)
  40.              (when (fboundp x) (princ " (defined)"))
  41.              (when (boundp x) (format t " value: ~s" x)))
  42.            (apropos-list string))
  43. #+:mulvals   (values)
  44. #-:mulvals   nil ; CL says return "nothing" but we need to return NIL
  45. )
  46.  
  47. (defun array-in-bounds-p (a n) (and (>= n 0 (< n (length a)))))
  48.  
  49. (defmacro assert (test forms &rest x &aux (loop (gensym)))
  50.       `(prog ((*print-length* 4) (*print-level* 4))
  51.          ,loop
  52.          (when ,test (return nil))
  53.          (cerror "requests new values for ~*~s"
  54.              "~a"             
  55.              (format nil ,@x)
  56.              ',forms)
  57.          ,@(mapcan #'(lambda (i)
  58.                      `((format t "Enter new value for ~s:" ',i)
  59.                        (setf ,i (read))))
  60.                forms)
  61.          (go ,loop)))
  62.  
  63. (defun assoc-if (test form &key (key #'identity))
  64.        (do ()
  65.        ((endp form) nil)
  66.        (when (and (consp (car form))
  67.               (funcall test (funcall key (caar form))))
  68.          (return (car form)))
  69.        (setq form (cdr form))))
  70.  
  71. (defun assoc-if-not (test form &key (key #'identity))
  72.        (do ()
  73.        ((endp form) nil)
  74.        (when (and (consp (car form))
  75.               (not (funcall test (funcall key (caar form)))))
  76.          (return (car form)))
  77.        (setq form (cdr form))))
  78.  
  79. (defmacro ccase (keyform &rest x)
  80.       (let ((val (gensym))
  81.         (loop (gensym))
  82.         (values (mapcan #'(lambda (x)
  83.                       (if (listp (car x))
  84.                           (copy-list (car x))
  85.                           (list (car x))))
  86.                 x)))
  87.            `(prog (,val) ,loop
  88.               (setf ,val ,keyform)
  89.               (return 
  90.                (case ,val
  91.                  ,@x
  92.                  (t (cerror
  93.                  "requests new value for ~s"
  94.                  "~*~s fell through ccase expression, wanted one of ~s"
  95.                  ',keyform
  96.                  ,val
  97.                  ',values)
  98.                 (format t "New value:")
  99.                 (setf ,keyform (read))
  100.                 (go ,loop)))))))
  101.                         
  102. (defun char-name (c)
  103.        (case c
  104.          (#\Space   "Space")
  105.          (#\Newline "Newline")
  106.          (#\Rubout  "Rubout")))
  107.  
  108. (defun character (arg) (coerce arg 'character))
  109.  
  110. (defmacro check-type (place type 
  111.                 &optional (string `',type) 
  112.                 &aux (loop (gensym)))
  113.        `(prog () ,loop
  114.           (when (typep ,place ',type) (return))
  115.           (cerror "requests new value for ~s"
  116.               "the value of ~s is ~s which is not of type ~a"
  117.               ',place
  118.               ,place
  119.               ,string)
  120.           (format t "New value:")
  121.           (setf ,place (read))
  122.           (go ,loop)))
  123.           
  124.  
  125. (defun copy-seq (seq) (subseq seq 0))
  126.  
  127. (defun copy-symbol (sym &optional all)
  128.        (unless (symbolp sym) (error "~s is not a symbol" sym))
  129.        (let ((x (make-symbol (symbol-name sym))))
  130.         (when all
  131.           (when (boundp sym) (setf (symbol-value x) sym))
  132.           (when (fboundp sym) 
  133.             (setf (symbol-function x) (symbol-function sym)))
  134.           (setf (symbol-plist x) (symbol-plist sym)))
  135.         x))
  136.  
  137. (defmacro ctypecase (keyform &rest x)
  138.       (let ((val (gensym))
  139.         (loop (gensym))
  140.         (values (mapcan #'(lambda (x)
  141.                       (if (listp (car x))
  142.                           (list (copy-list (car x)))
  143.                           (list (car x))))
  144.                 x)))
  145.            `(prog (,val) ,loop
  146.               (setq ,val ,keyform)
  147.               (return 
  148.                (typecase ,val
  149.                  ,@x
  150.                  (otherwise (cerror
  151.                  "requests new value for ~s"
  152.                  "~*~s fell through ctypecase expression, wanted one of ~s"
  153.                  ',keyform
  154.                  ,val
  155.                  ',values)
  156.                 (format t "New value:")
  157.                 (setf ,keyform (read))
  158.                 (go ,loop)))))))
  159.                         
  160. (setf (symbol-function 'delete-duplicates)      ; cheat on this one
  161.       (symbol-function 'remove-duplicates))
  162.  
  163. #-:packages
  164. (defmacro do-all-symbols (arglist &rest body)
  165.       (when (not (consp arglist)) (error "Bad first argument"))
  166.       `(dolist ( ,(first arglist)
  167.              ',(mapcan #'copy-list (coerce *obarray* 'list))
  168.              ,@(rest arglist))
  169.            ,@body))
  170.  
  171. (defmacro ecase (keyform &rest x)
  172.       (let ((tmp (gensym))
  173.         (values (mapcan #'(lambda (x)
  174.                       (if (listp (car x))
  175.                           (copy-list (car x))
  176.                           (list (car x))))
  177.                 x)))
  178.            `(let ((,tmp ,keyform))
  179.              (case ,tmp ,@x 
  180.                (t (error "case ~s not one of ~s" ,tmp ',values))))))
  181.  
  182. (defmacro etypecase (keyform &rest x)
  183.       (let ((tmp (gensym))
  184.         (values (mapcan #'(lambda (x)
  185.                       (if (listp (car x))
  186.                           (list (copy-list (car x)))
  187.                           (list (car x))))
  188.                 x)))
  189.            `(let ((,tmp ,keyform))
  190.              (typecase ,tmp ,@x 
  191.                (otherwise (error "type of ~s not one of ~s" ,tmp ',values))))))
  192.  
  193. ;; These are terribly inefficient (see the awful defsetf code in common.lsp)
  194. (defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))  ; same as "car"
  195. (defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))   ; same as "cdr"
  196.  
  197. (defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  198. (defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  199. (defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  200. (defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
  201. (defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
  202. (defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
  203. (defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
  204. (defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
  205. (defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
  206.  
  207. (defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  208. (defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
  209. (defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
  210. (defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
  211. (defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
  212. (defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
  213. (defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
  214. (defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  215. (defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
  216. (defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
  217. (defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
  218. (defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
  219. (defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
  220. (defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
  221. (defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
  222. (defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
  223. (defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
  224. (defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
  225. (defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
  226. (defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  227. (defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
  228. (defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
  229. (defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
  230. (defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
  231. (defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
  232. (defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
  233. (defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
  234. (defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
  235.  
  236. (defun fifth (x) (nth 4 x))
  237. (defun sixth (x) (nth 5 x))
  238. (defun seventh (x) (nth 6 x))
  239. (defun eighth (x) (nth 7 x))
  240. (defun ninth (x) (nth 8 x))
  241. (defun tenth (x) (nth 9 x))
  242.  
  243. (defun float-sign (x &optional (y 1.0))
  244.        (if (minusp x) (- (abs y))
  245.        (abs y)))
  246.  
  247. (defun hash-table-p (x) (typep x 'hash-table))
  248.  
  249. (defun isqrt (x) (floor (sqrt x)))
  250.  
  251. #+:packages
  252. (defun keywordp (x) (eq (symbol-package x) (find-package "KEYWORD")))
  253. #-:packages
  254. (defun keywordp (x) 
  255.        (and (symbolp x) (eq #\: (aref (symbol-name x) 0))))
  256.  
  257. #+:packages
  258. (defun packagep (x) (typep x 'package))
  259.  
  260. (defun ldiff (l m)
  261.        (do ((list l (cdr list)))
  262.        ((endp list) (copy-list l))
  263.        (when (eq m list) (return (butlast l (length list))))))
  264.  
  265. ; This won't make really big lists in MS-DOS environments
  266. (defun make-list (n &key initial-element &aux val)
  267.        (coerce (make-array n :initial-element initial-element) 'list))
  268.  
  269. ; This will make bigger lists, but is about 5x slower
  270. ;(defun make-list (n &key initial-element &aux val)
  271. ;       (dotimes (i n val) (push initial-element val)))
  272.  
  273. ; These won't make really big strings/sequences in MS-DOS environments, but
  274. ;  I'm not giving an alternative!
  275. (defun make-string (n &key (initial-element #\space))
  276.        (coerce (make-array n :initial-element initial-element) 'string))
  277.  
  278. (defun make-sequence (type n 
  279.                &key (initial-element
  280.                  (if (eq type 'string) #\space nil)))
  281.        (coerce (make-array n :initial-element initial-element) type))
  282.  
  283. (defun member-if (test form &key (key #'identity))
  284.        (do ()
  285.        ((endp form) nil)
  286.        (when (funcall test (funcall key (car form))) (return form))
  287.        (setq form (cdr form))))
  288.  
  289. (defun member-if-not (test form &key (key #'identity))
  290.        (do ()
  291.        ((endp form) nil)
  292.        (unless (funcall test (funcall key (car form))) (return form))
  293.        (setq form (cdr form))))
  294.  
  295. (defun merge (type s1 s2 pred &key (key #'identity))
  296.        (let* ((i1 0)
  297.           (i2 0)
  298.           (i3 0)
  299.           (l1 (length s1))
  300.           (l2 (length s2))
  301.           (l3 (+ l1 l2))
  302.           (res (make-sequence type l3)))
  303.          (loop
  304.           (when (eql i3 l3) (return res))
  305.           (setf (elt res i3)
  306.             (cond
  307.              ((eql i1 l1)
  308.               (prog1 (elt s2 i2) (incf i2)))
  309.              ((eql i2 l2)
  310.               (prog1 (elt s1 i1) (incf i1)))
  311.              ((funcall pred 
  312.                    (funcall key (elt s1 i1)) 
  313.                    (funcall key (elt s2 i2)))
  314.               (prog1 (elt s1 i1) (incf i1)))
  315.              (t
  316.               (prog1 (elt s2 i2) (incf i2)))))
  317.           (incf i3))))
  318.  
  319. (defun mismatch (sequence1 sequence2
  320.             &key 
  321.             (key #'identity) 
  322.             test test-not 
  323.             (start1 0) end1
  324.             (start2 0) end2)
  325.        (when (null end1) (setq end1 (length sequence1)))
  326.        (when (null end2) (setq end2 (length sequence2)))
  327.        (when (and test test-not)
  328.          (error "cannot specify both :test and :test-not"))
  329.        (if test-not
  330.        (setq test test-not test-not #'not)
  331.        (progn (setq test-not #'identity)
  332.           (unless test (setq test #'eql))))
  333.        (do* ((s1 start1 (1+ s1))
  334.          (s2 start2 (1+ s2)))
  335.         ((or (>= s1 end1) (>= s2 end2))
  336.          (if (and (>= s1 end1) (>= s2 end2))
  337.          nil
  338.          s1))
  339.         (unless (funcall test-not 
  340.                  (funcall test 
  341.                       (funcall key (elt sequence1 s1))
  342.                       (funcall key (elt sequence2 s2))))
  343.             (return s1))))
  344.  
  345. ; There are numerous n* functions that I'm not implementing because
  346. ; They would be slower then the builtin, non-destructive equivalents.
  347.  
  348.  
  349. (defun nbutlast (list &optional (n 1) &aux (l (length list)))
  350.        (if (< n l)
  351.        (prog2 (setf (cdr (nthcdr (1- (- l n)) list)) nil) list)
  352.        nil))
  353.  
  354. (defun nreconc (l1 l2) (nconc (nreverse l1) l2))
  355.  
  356. (defun prin1-to-string (arg) (format nil "~s" arg))
  357. (defun princ-to-string (arg) (format nil "~a" arg))
  358.  
  359. (defun probe-file (arg) (open arg :direction :probe))
  360.  
  361. (defun rassoc (i form &key (key #'identity) test test-not)
  362.        (when (and test test-not)
  363.          (error "cannot specify both :test and :test-not"))
  364.        (if test-not
  365.        (do ()
  366.            ((endp form) nil)
  367.            (when (and (consp (car form))
  368.               (not (funcall test-not i (funcall key (cdar form)))))
  369.              (return (car form)))
  370.            (setq form (cdr form)))
  371.        (progn (unless test (setq test #'eql))
  372.           (do ()
  373.               ((endp form) nil)
  374.               (when (and (consp (car form))
  375.                  (funcall test i (funcall key (cdar form))))
  376.                 (return (car form)))
  377.               (setq form (cdr form))))))
  378.        
  379. (defun rassoc-if (test form &key (key #'identity))
  380.        (do ()
  381.        ((endp form) nil)
  382.        (when (and (consp (car form))
  383.               (funcall test (funcall key (cdar form))))
  384.          (return (car form)))
  385.        (setq form (cdr form))))
  386.  
  387. (defun rassoc-if-not (test form &key (key #'identity))
  388.        (do ()
  389.        ((endp form) nil)
  390.        (when (and (consp (car form))
  391.               (not (funcall test (funcall key (cdar form)))))
  392.          (return (car form)))
  393.        (setq form (cdr form))))
  394.  
  395. (defun read-from-string (arg)
  396.        (read (make-string-input-stream arg)))
  397.  
  398. (defun realp (arg) (or (integerp arg) (floatp arg)))
  399.  
  400. (defun revappend (x y) (nconc (reverse x) y))
  401.  
  402. (defun tailp (s l)
  403.        (do ()
  404.        ((endp l) nil)
  405.        (when (eq s l) (return t))
  406.        (setq l (cdr l))))
  407.  
  408. (defmacro typecase (keyform &rest x &aux (tmp (gensym)))
  409.       `(let ((,tmp ,keyform))
  410.         (cond 
  411.               ,@(mapcar #'(lambda (x)
  412.                      (if (eq (first x) 'otherwise)
  413.                          `(t ,@(rest x))
  414.                          `((typep ,tmp ',(first x))
  415.                            ,@(rest x))))
  416.                 x))))
  417.  
  418. (defun sleep (time)
  419.        (let ((endtime (+ time (/ (get-internal-real-time)
  420.                  internal-time-units-per-second))))
  421.         (loop (when (> (/ (get-internal-real-time)
  422.                   internal-time-units-per-second)
  423.                endtime)
  424.             (return nil)))))
  425.  
  426. (defmacro with-open-stream (stream-args &rest body)
  427.       `(let ((,(first stream-args) ,(second stream-args)))
  428.         (unwind-protect
  429.          (progn ,@body)
  430.          (when ,(first stream-args) (close ,(first stream-args))))))
  431.